home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1995 January / macformat-020.iso / Shareware City / Developers / SIOD 3.0 / siod.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-10-01  |  3.4 KB  |  164 lines  |  [TEXT/ttxt]
  1. /* Scheme In One Defun, but in C this time.
  2.  
  3.  *                    COPYRIGHT (c) 1988-1994 BY                            *
  4.  *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  5.  *        See the source file SLIB.C for more information.                  *
  6.  
  7. */
  8.  
  9. /*
  10.  
  11. gjc@paradigm.com or gjc@mitech.com or gjc@world.std.com
  12.  
  13. Paradigm Associates Inc          Phone: 617-492-6079
  14. 29 Putnam Ave, Suite 6
  15. Cambridge, MA 02138
  16.  
  17. An example main-program call with some customized subrs.
  18.  
  19.   */
  20.  
  21. #include <stdio.h>
  22. #include <stdlib.h>
  23. #include <string.h>
  24. #ifdef THINK_C
  25. #include <console.h>
  26. #endif
  27.  
  28. #include "siod.h"
  29.  
  30. LISP my_one;
  31. LISP my_two;
  32. LISP my_99;
  33. LISP my_0;
  34.  
  35.  
  36. LISP cfib(LISP x);
  37. LISP clooptest(LISP x,LISP f);
  38.  
  39. #ifdef VMS
  40. LISP vms_debug(LISP cmd);
  41. #endif
  42.  
  43. #ifdef WIN32
  44. #include <windows.h>
  45. LISP win32_debug(void)
  46. {DebugBreak();
  47.  return(NIL);}
  48. #endif
  49.  
  50. int main(int argc,char **argv)
  51. {int j,xflag = 0,retval = 0;
  52.  char *linebuffer = NULL,*ptr;
  53.  print_welcome();
  54. #ifdef THINK_C
  55.  argc = ccommand(&argv);
  56. #endif
  57.  for(j=1;j<argc;++j)
  58.    if (strcmp(argv[j],"x") == 0)
  59.      xflag = 1;
  60.    else if (strncmp(argv[j],"-e",2) == 0)
  61.      {xflag = 2;
  62.       linebuffer = &argv[j][2];}
  63.  process_cla(argc,argv,(xflag) ? 0 : 1);
  64.  print_hs_1();
  65.  init_storage();
  66.  init_subrs();
  67.  init_trace();
  68.  my_one = flocons((double) 1.0);
  69.  my_two = flocons((double) 2.0);
  70.  my_99 = flocons((double) 99.0);
  71.  my_0 = flocons((double) 0.0);
  72.  gc_protect(&my_one);
  73.  gc_protect(&my_two);
  74.  gc_protect(&my_99);
  75.  gc_protect(&my_0);
  76.  init_subr_1("cfib",cfib);
  77.  init_subr_2("cloop-test",clooptest);
  78. #ifdef VMS
  79.  init_subr_1("vms-debug",vms_debug);
  80. #endif
  81. #ifdef WIN32
  82.  init_subr_0("win32-debug",win32_debug);
  83. #endif
  84. #ifdef INIT_EXTRA
  85.  INIT_EXTRA();
  86. #endif
  87.  switch(xflag)
  88.    {case 0:
  89.       retval = repl_driver(1,1,NULL);
  90.       break;
  91.     case 1:
  92.       printf("Using repl_c_string\n");
  93.       linebuffer = (char *) malloc(256);
  94.       while(fgets(linebuffer,256,stdin))
  95.     {if ((ptr = strchr(linebuffer,'\n'))) *ptr = 0;
  96.      retval = repl_c_string(linebuffer,1,xflag,0);
  97.      xflag = 0;}
  98.       break;
  99.     case 2:
  100.       retval = repl_c_string(linebuffer,1,xflag,1);
  101.       break;}
  102.  printf("EXIT\n");
  103.  exit(retval);
  104.  return(0);}
  105.  
  106. /* This is cfib, (compiled fib). Test to see what the overhead
  107.    of interpretation actually is in a given implementation benchmark
  108.    standard-fib against cfib.
  109.  
  110.    (define (standard-fib x)
  111.      (if (< x 2)
  112.          x
  113.          (+ (standard-fib (- x 1))
  114.         (standard-fib (- x 2)))))  
  115.  
  116. */
  117.  
  118. LISP cfib(LISP x)
  119. {if NNULLP(lessp(x,my_two))
  120.    return(x);
  121.  else
  122.    return(plus(cfib(difference(x,my_one)),
  123.            cfib(difference(x,my_two))));}
  124.  
  125. /* compiled version of loop-test from siod.scm
  126.    This won't number-cons for n up to 99 (with default arguments).
  127.    Another test of overhead of interpretation */
  128.  
  129. LISP clooptest(LISP n,LISP f)
  130. {LISP j,k,m,result;
  131.  j = my_0;
  132.  result = NIL;
  133.  while(NNULLP(lessp(j,n)))
  134.    {j = plus(j,my_one);
  135.     k = my_0;
  136.     while(NNULLP(lessp(k,my_99)))
  137.       {k = plus(k,my_one);
  138.        m = my_0;
  139.        while(NNULLP(lessp(m,my_99)))
  140.      {m = plus(m,my_one);
  141.       if NNULLP(f) result = cons(NIL,result);}}}
  142.  return(result);}
  143.  
  144. #ifdef VMS
  145.  
  146. #include <ssdef.h>
  147. #include <descrip.h>
  148. #include <lib$routines.h>
  149.  
  150. LISP vms_debug(arg)
  151.      LISP arg;
  152. {unsigned char arg1[257];
  153.  char *data;
  154.  if NULLP(arg)
  155.    lib$signal(SS$_DEBUG,0);
  156.  else
  157.    {data = get_c_string(arg);
  158.     arg1[0] = strlen(data);
  159.     memcpy(&arg1[1],data,arg1[0]);
  160.     lib$signal(SS$_DEBUG,1,arg1);}
  161.  return(NIL);}
  162.  
  163. #endif
  164.